home *** CD-ROM | disk | FTP | other *** search
Text File | 1994-09-27 | 11.6 KB | 251 lines | [TEXT/CCL2] |
-
- ;;; The `prune' function removes instantiated type variables at the
- ;;; top level of a type.
-
- ;;; It returns an uninstantiated type variable or a type constructor.
-
- (define-integrable (prune ntype)
- (if (ntyvar? ntype)
- (if (instantiated? ntype)
- (prune-1 (ntyvar-value ntype))
- ntype)
- ntype))
-
- ;;; This is because lucid can't hack inlining recursive fns.
-
- (define (prune-1 x) (prune x))
-
- (define-integrable (instantiated? ntyvar)
- (ntyvar-value ntyvar))
- ; (not (eq? (ntyvar-value ntyvar) '#f))) ;*** Lucid compiler bug?
-
- (define (prune/l l)
- (map (function prune) l))
-
-
- ;;; These functions convert between AST types and gtypes. Care is taken to
- ;;; ensure that the gtyvars are in the same order that they appear in the
- ;;; context. This is needed to make dictionary conversion work right.
-
- (define (ast->gtype context type)
- (mlet (((gcontext env) (context->gcontext context '() '()))
- ((type env1) (type->gtype type env))
- (gcontext-classes (arrange-gtype-classes env1 gcontext)))
- (**gtype gcontext-classes type)))
-
- ;;; This is similar except that the ordering of the tyvars is as defined in
- ;;; the data type. This is used only for instance declarations and allows
- ;;; for simple context implication checks. It also used by the signature
- ;;; of the dictionary variable.
-
- (define (ast->gtype/inst context type)
- (mlet (((type env) (type->gtype type '()))
- ((gcontext env1) (context->gcontext context '() env))
- (gcontext-classes (arrange-gtype-classes env1 gcontext)))
- (**gtype gcontext-classes type)))
-
- ;;; This converts a context into gtype form [[class]]: a list of classes
- ;;; for each gtyvar. This returns the context and the gtyvar environment.
-
- (define (context->gcontext context gcontext env)
- (if (null? context)
- (values gcontext env)
- (mlet ((sym (context-tyvar (car context)))
- (class (class-ref-class (context-class (car context))))
- ((n new-env) (ast->gtyvar sym env))
- (old-context (get-gtyvar-context n gcontext))
- (new-context (merge-single-class class old-context))
- (new-gcontext (cons (tuple n new-context) gcontext)))
- (context->gcontext (cdr context) new-gcontext new-env))))
-
- ;;; This assigns a gtyvar number to a tyvar name.
-
- (define (ast->gtyvar sym env)
- (let ((res (assq sym env)))
- (if (eq? res '#f)
- (let ((n (length env)))
- (values n (cons (tuple sym n) env)))
- (values (tuple-2-2 res) env))))
-
- (define (get-gtyvar-context n gcontext)
- (cond ((null? gcontext)
- '())
- ((eqv? n (tuple-2-1 (car gcontext)))
- (tuple-2-2 (car gcontext)))
- (else (get-gtyvar-context n (cdr gcontext)))))
-
- (define (type->gtype type env)
- (if (tyvar? type)
- (mlet (((n env1) (ast->gtyvar (tyvar-name type) env)))
- (values (**gtyvar n) env1))
- (mlet (((types env1) (type->gtype/l (tycon-args type) env)))
- (values (**ntycon (tycon-def type) types) env1))))
-
- (define (type->gtype/l types env)
- (if (null? types)
- (values '() env)
- (mlet (((type env1) (type->gtype (car types) env))
- ((other-types env2) (type->gtype/l (cdr types) env1)))
- (values (cons type other-types) env2))))
-
- (define (arrange-gtype-classes env gcontext)
- (arrange-gtype-classes-1 0 (length env) env gcontext))
-
- (define (arrange-gtype-classes-1 m n env gcontext)
- (if (equal? m n)
- '()
- (cons (get-gtyvar-context m gcontext)
- (arrange-gtype-classes-1 (1+ m) n env gcontext))))
-
- ;;; These routines convert gtypes back to ordinary types.
-
- (define (instantiate-gtype g)
- (mlet (((gtype _) (instantiate-gtype/newvars g)))
- gtype))
-
- (define (instantiate-gtype/newvars g)
- (if (null? (gtype-context g))
- (values (gtype-type g) '())
- (let ((new-tyvars (create-new-tyvars (gtype-context g))))
- (values (copy-gtype (gtype-type g) new-tyvars) new-tyvars))))
-
- (define (create-new-tyvars ctxts)
- (if (null? ctxts)
- '()
- (let ((tyvar (**ntyvar)))
- (setf (ntyvar-context tyvar) (map (function forward-def) (car ctxts)))
- (cons tyvar (create-new-tyvars (cdr ctxts))))))
-
- (define (copy-gtype g env)
- (cond ((ntycon? g)
- (**ntycon (forward-def (ntycon-tycon g))
- (map (lambda (g1) (copy-gtype g1 env))
- (ntycon-args g))))
- ((ntyvar? g)
- g)
- ((gtyvar? g)
- (list-ref env (gtyvar-varnum g)))
- ((const-type? g)
- (const-type-type g))))
-
- ;;; ntypes may contain synonyms. These are expanded here. Only the
- ;;; top level synonym is expanded.
-
- (define (expand-ntype-synonym type)
- (let ((type (prune type)))
- (if (ntycon? type)
- (let ((syn (forward-def (ntycon-tycon type))))
- (if (synonym? syn)
- (expand-ntype-synonym
- (expand-ntype-synonym-1 (synonym-body syn)
- (map (car ctxt1) (car ctxt2))
- (full-context-implies? (cdr ctxt1) (cdr ctxt2)))))
-
- ;;; This is used to avoid type circularity on unification.
-
- (define (occurs-in-type tyvar type) ; Cardelli algorithm
- (let ((type (prune type)))
- (if (ntyvar? type)
- (eq? type tyvar)
- (occurs-in-type/l tyvar (ntycon-args type)))))
-
- ; Does a tyvar occur in a list of types?
- (define (occurs-in-type/l tyvar types)
- (if (null? types)
- '#f
- (or (occurs-in-type tyvar (car types))
- (occurs-in-type/l tyvar (cdr types)))))
-
- (define-integrable (non-generic? tyvar)
- (occurs-in-type/l tyvar (dynamic *non-generic-tyvars*)))
-
- (define (collect-tyvars ntype)
- (collect-tyvars-1 ntype '()))
-
- (define (collect-tyvars-1 ntype vars)
- (let ((ntype (prune ntype)))
- (if (ntyvar? ntype)
- (if (or (memq ntype vars) (non-generic? ntype))
- vars
- (cons ntype vars))
- (collect-tyvars/l-1 (ntycon-args ntype) vars))))
-
- (define (collect-tyvars/l types)
- (collect-tyvars/l-1 types '()))
-
- (define (collect-tyvars/l-1 types vars)
- (if (null? types)
- vars
- (collect-tyvars/l-1 (cdr types) (collect-tyvars-1 (car types) vars))))
-
- ;;; Random utilities
-
- (define (decl-var decl)
- (var-ref-var (var-pat-var (valdef-lhs decl))))
-
- ;;; Support for dynamic typing
-
- (define (rconvert-gtype gtype)
- (**app (**con/def (core-symbol "MkSignature"))
- (rconvert-context (gtype-context gtype))
- (rconvert-ntype (gtype-type gtype))))
-
- (define (rconvert-context ctxt)
- (**list/l (map (lambda (cl)
- (**list/l (map (lambda (c)
- (**var/def (class-runtime-var c)))
- cl)))
- ctxt)))
-
- (predefine (remember-placeholder p))
-
- (define (rconvert-ntype ntype)
- (setf ntype (expand-ntype-synonym ntype))
- (cond ((ntycon? ntype)
- (let ((tycon (forward-def (ntycon-tycon ntype))))
- (if (algdata-skolem-type? tycon)
- (rconvert-tycon tycon)
- (**app (**con/def (core-symbol "Tycon"))
- (rconvert-tycon tycon)
- (**list/l (map (function rconvert-ntype)
- (ntycon-args ntype)))))))
- ((gtyvar? ntype)
- (**app (**con/def (core-symbol "Tyvar"))
- (**int (gtyvar-varnum ntype))))
- ((ntyvar? ntype)
- (setf (ntyvar-context ntype)
- (if (null? (ntyvar-context ntype))
- (list (core-symbol "DynamicType"))
- (merge-contexts (list (core-symbol "DynamicType"))
- (ntyvar-context ntype))))
- (let ((p (**dtype-placeholder ntype)))
- (remember-placeholder p)
- p))
- (else
- (error "Bad gtype in rconvert-ntype!"))))
-
- (define (rconvert-tycon tycon)
- (setf tycon (forward-def tycon))
- (if (eq? tycon *undefined-def*)
- (**null) ; just filler
- (if (algdata-real-tuple? tycon)
- (**app (**var/def (core-symbol "genTupleType"))
- (**int (tuple-constructor-arity
- (car (algdata-constrs tycon)))))
- (**var/def (algdata-runtime-var tycon)))))
-
- (define (**dtype-placeholder tyvar)
- (make dtype-placeholder (exp '#f) (tyvar tyvar)))
-
-
- ;;; This removed the dynamic class from a context
-
- (define (remove-dynamic classes)
- (if (null? classes)
- '()
- (if (eq? (car classes) (core-symbol "DynamicType"))
- (cdr classes)
- (cons (car classes) (remove-dynamic (cdr classes))))))
-
-
-